;;************************
;; contains new namelist protos and modifications to name-list-proto
;;
;; NOTE: For Windows, the default name-list is no longer the original 
;; name-list-proto, but is name-list-proto2 (in order to have overlays)
;;
;; The new prototypes, and their constructor functions, are:
;; name-list-proto2       - (name-list) 
;; varobs-list-proto      - (make-var-list) and (make-obs-list)
;; double-name-list-proto - (double-name-list)
;;
;; varobs-list-proto      uses name-list-proto2
;; double-name-list-proto uses name-list-proto


(defun selector (&optional (data $) &key (in nil))
  (when in (enable-container in))
  (let* ((vars (send data :variables))
         (obs  (send data :labels))
         (nvar (length vars))
         (nobs (length obs ))
         (selc (double-name-list 
                vars obs 
                :title (format nil "Selector: ~a" (send data :name))
                :location '(0 0)
                :in in))
         )
    selc))


;   (listeners)

;;*****************
;; name-list-proto2
;;*****************


(defun name-list (&optional names &key (show t) (title "Namelist") 
                            (size '(125 250)) (location '(100 100)) 
                            (vertical t) (in *active-container*) 
                            (style 0) (help-only nil) (hot-spot nil))
"Args: &OPTIONAL NAMES &KEY (IN *ACTIVE-CONTAINER*) (VERTICAL T) (HELP-ONLY T) (HOT-SPOT NIL) (SHOW T) (TITLE \"NAMELIST\") (SIZE (125 250)) (LOCATION (100 100))
Makes a namelist of NAMES with button bar by using containers. Always has horizontal button bar with help button. By default has IN OUT DROP and RESET buttons on vertical bar (horizontal bar when VERTICAL is NIL). Only has help button if HELP-ONLY is T (forces VERTICAL to be NIL). Also has HOT-SPOT for pull-down menus, and two menus if HOT-SPOT is T."
  (when help-only (setf vertical nil))
  (let ((nl (send name-list-proto2 :new names :help-only help-only :hot-spot hot-spot
                  :show show :title title :size size :location location 
                  :in in :style style :vertical vertical)))
    (when show (send nl :show-window))
    nl))

(defproto name-list-proto2 '(container vertical in) () name-list-proto)

(defmeth name-list-proto2 :vertical (&optional (objid nil set))
  (if set (setf (slot-value 'vertical) objid))
  (slot-value 'vertical))

(defmeth name-list-proto2 :container (&optional (objid nil set))
  (if set (setf (slot-value 'container) objid))
  (slot-value 'container))


(defmeth name-list-proto2 :in (&optional (objid nil set))
  (if set (setf (slot-value 'in) objid))
  (slot-value 'in))

(defmeth name-list-proto2 :isnew 
  (names &key (show nil) (vertical t) (in *active-container*) (hot-spot t)
         (help-only nil) (style 0) title size location)
  (let* ((actcon *active-container*)
         (nl-container (container :in in :style style :show nil :localmenu nil
                             :title title :size size :location location ))
         (fake-overlayh   (send graph-proto :new 2 :show nil))
         (fake-overlayv   nil)
         (namelist (call-next-method 0 :show nil))
         (t/nil))
    (send self :in in)
    (send self :add-slot 'fake-overlayh fake-overlayh)
    (defmeth self :fake-overlayh (&optional (objid nil set))
      (if set (setf (slot-value 'fake-overlayh) objid))
      (slot-value 'fake-overlayh))
    (send fake-overlayh   :add-slot 'namelist namelist)
    (defmeth fake-overlayh   :namelist (&optional (objid nil set))
      (if set (setf (slot-value 'namelist) objid))
      (slot-value 'namelist))
    (defmeth fake-overlayh   :plot-help ()
      (send (send self :namelist) :plot-help))
    (send self :vertical vertical)
    (when vertical 
          (setf fake-overlayv   (send graph-proto :new 2 :show nil))
          (send fake-overlayv   :add-slot 'namelist namelist)
          (defmeth fake-overlayv   :namelist (&optional (objid nil set))
            (if set (setf (slot-value 'namelist) objid))
            (slot-value 'namelist))
          (defmeth fake-overlayv   :plot-help ()
            (send (send self :namelist) :plot-help))
          (send self :add-slot 'fake-overlayv fake-overlayv)
          (defmeth self :fake-overlayv (&optional (objid nil set))
            (if set (setf (slot-value 'fake-overlayv) objid))
            (slot-value 'fake-overlayv))
          )
    (send nl-container :add-slot 'namelist namelist)
    (defmeth nl-container :namelist (&optional (objid nil set))
      (if set (setf (slot-value 'namelist) objid))
      (slot-value 'namelist))
    (send nl-container :add-slot 'fake-overlayh fake-overlayh )
    (defmeth nl-container :fake-overlayh  (&optional (objid nil set))
      (if set (setf (slot-value 'fake-overlayh ) objid))
      (slot-value 'fake-overlayh ))
    (send nl-container :add-slot 'fake-overlayv fake-overlayv )
    (defmeth nl-container :fake-overlayv  (&optional (objid nil set))
      (if set (setf (slot-value 'fake-overlayv ) objid))
      (slot-value 'fake-overlayv ))
    (send fake-overlayh :top-most nil)
    (send fake-overlayh :back-color 'toolbar-background)
    (send nl-container :menu nil)
    (send nl-container :use-color t)
    (send namelist :container nl-container)
    (send namelist :menu-template 
          '(LINK MOUSE DASH ERASE-SELECTION FOCUS-ON-SELECTION 
                 SHOW-ALL COLOR))
    (send namelist :frame-location 18 18);0 18
    (send namelist :clear)
    (send namelist :use-color t)
    (send namelist :menu nil)
    (send namelist :new-menu nil)
    (if vertical (setf t/nil nil)
        (if help-only (setf t/nil nil) (setf t/nil t)))
    (send fake-overlayh :select-buttons :vertical nil :help t :hot-spot hot-spot ;fwy 
              :out t/nil :in t/nil :cancel t/nil :reset t/nil)
    (send fake-overlayh :clear)
    (send fake-overlayh :new-menu nil)
    (send fake-overlayh :menu nil)
    (send fake-overlayh :new-menu "menu" :items
             '(LINK MOUSE DASH ERASE-SELECTION FOCUS-ON-SELECTION 
                 SHOW-ALL COLOR))
    (send fake-overlayh :use-color t)
    (send fake-overlayh :redraw)
    (when vertical
          (send fake-overlayv :select-buttons :vertical t :hot-spot hot-spot    ;fwy
                :help nil :hot-spot nil :out t :in t :cancel t :reset t)
          (send fake-overlayv :clear)
          (send fake-overlayv :new-menu nil)
          (send fake-overlayv :menu nil)
          (send fake-overlayv :use-color t)
          (send fake-overlayv :redraw))
    
    (defmeth nl-container :resize ()
      (call-next-method)
      (let* ((my-size (send self :size))
             (w (first my-size))
             (h (second my-size))
             )
        (send (send self :namelist) :size (- w 0) h)))
    (if (not names) 
        (send self :clear)
        (if (listp names) 
            (send self :add-points (list (iseq (length names))) 
                  :point-labels names)
            (send self :add-points names)))
    (if actcon
        (enable-container actcon)
        (disable-container))
    (apply #'send self :size size)
    (apply #'send self :location location)
    (send self :location-structure)
    (setf fov fake-overlayv)
    (setf foh fake-overlayh)
    (send fake-overlayh :container nl-container)
    (when fake-overlayv (send fake-overlayv :container nl-container))
    (setf nl namelist)
    self))

  (defmeth name-list-proto2 :make-two-namelist-menus (title &key hotspot-items popup-items)
  "Args: TITLE &KEY HOTSPOT-ITEMS POPUP-ITEMS
  Makes pull-down and popup menus for namelists. TITLE is title of the menu.  POPUP-ITEMS is a set of  menu items that popup from the plot when the namelist is right-clicked. HOTSPOT-ITEMS is the set of  menu items that popup from the window when the namelist is control-right-clicked or when the hotspot in the fake-menubar is left-clicked."
;store items in a slot - create secondary items, store in slot
;(break)
     (send self :make-hotspot-menu-items hotspot-items) 
     (send self :make-popup-menu-items popup-items ) 
     (when (send self :menu)  ;remove menu from menubar so it can be popped up
           (send (send self :menu) :graph self)	
           (send (send self :menu) :remove))
     (let* ((overlay (send self :fake-overlayh))
            (overlay-hotspot-menu-items 
               (send overlay :make-hotspot-menu-items hotspot-items))
            (overlay-menu (send overlay :new-menu))
            )
        (send overlay-menu :graph overlay)
        (send overlay-menu :remove)
        (apply #'send overlay-menu :append-items overlay-hotspot-menu-items)
        (defmeth overlay :do-click (x y m1 m2) (call-next-method x y m1 m2))
        )
     (defmeth self :do-click (x y m1 m2)
       (let* ((hotspot-menu-items (send self :hotspot-menu-items))
              (popup-menu-items (send self :popup-menu-items))
              (line-type (send self :line-type))
              (menu (send self :menu)))
	 (print (list x y m1 m2))  ; m1 cntl-click  m2 right-click
	 (when menu (send menu :remove))
         (cond 
          ((and m1 m2)  
          (print ";hotspot menu - cntl-right-click anywhere")
           (when (and hotspot-menu-items (> y 18))
                 (apply #'send menu :delete-items (send menu :items))
                 (apply #'send menu :append-items hotspot-menu-items)
                 (send menu :popup-menu x y self)))
          (m2   (print ";popup menu - right-click anywhere")
           (when (and popup-items (> y 18))
                      ;(print ";popup menu - right-click on graph")
                 (apply #'send menu :delete-items (send menu :items))
                 (apply #'send menu :append-items popup-menu-items)
                 (send menu :popup-menu x y self)))
          (t      (print "selection methods ;left-click or control-left-click anywhere")
           (apply #'send menu :delete-items (send menu :items))
           (apply #'send menu :append-items hotspot-menu-items)
           (send $ :mat-states (send self :point-state (iseq (send self :num-points))))
           (call-next-method x y m1 m2)))
          (send self :menu menu)
          (send self :line-type line-type)
          )
       t)
     (send self :menu))


(defmeth name-list-proto2 :title (&optional string)
      (if string 
          (send (send self :container) :title string)
          (send (send self :container) :title)))

(defmeth name-list-proto2 :show-window ()
  (send (send (send self :container) :fake-overlayh) :show-window)
  (when (send self :vertical)
        (send (send (send self :container) :fake-overlayv) :show-window))
  (call-next-method)
  (send (send self :container) :show-window)
  )

(defmeth name-list-proto2 :location-structure ()
  (send (send (send self :container) :fake-overlayh) :margin 0 30 0 0) ;0 30
  (send (send (send self :container) :fake-overlayh) :location 4 13);fl 0 0
  (cond 
    ((send self :vertical)
     (send (send (send self :container) :fake-overlayv) :margin 20 0 0 0)
     (send (send (send self :container) :fake-overlayv) :frame-location 0 18);fl 0 18
     (send self :frame-location 18 18))
    (t (send self :frame-location 0 18)))
  )

(defmeth name-list-proto2 :resize ()
  (let ((content-rect 
         (list (max (mapcar #'(lambda (point)	
                                (send self :text-width 
                                      (send self :point-label point)))
                            (iseq (send self :num-points))))
               (* (send self :num-points)
                  (+ (send self :text-ascent) 3
                     (send self :text-descent)))))
        (size (send self :size)))
    (call-next-method)
    (send self :has-h-scroll
          (if (> (first content-rect)
                 (first size)) (first content-rect) nil))
    (send self :has-v-scroll 
          (if (> (second content-rect)
                 (- (second size) 17))
              (second content-rect) nil))
    ))
                  
(defmeth name-list-proto2 :location (&optional x y)
  (if (or x y)
        (send (send self :container) :location x y)
      (send (send self :container) :location)));PV was  (send (send self :container) :location x y

(defmeth name-list-proto2 :size (&optional w h)
  (when (and w h)
        (send (send (send self :container) :fake-overlayh) :size w 3)
        (cond 
          ((send self :vertical)
           (apply #'call-next-method 
                  (if (send self :in)
                      (if (send (send self :in) :pop-out)
                          (list (- w 20) (- h 10))
                          (if (send (send self :container) :pop-out)
                              (list (- w 26) (- h 42))
                              (list (- w 20)(- h 20))));20 20 ok splot
                      (list (- w 25) (- h 45))))  ;25 45 ok label-plot
           (send (send (send self :container) :fake-overlayv) :frame-size 18 (+ 10 h)))
          (t
           (call-next-method 
               (if (send (send self :container) :pop-out) (- w 8) w) (- h 42)))) ;(- w 2)(- h 10)
        (send (send self :container) :size w h)
        )
  (send (send self :container) :size))

(defmeth name-list-proto2 :close ()
  (send (send (send self :container) :fake-overlayh) :close)
  (when (send self :vertical)
        (send (send (send self :container) :fake-overlayv) :close))
  (send (send self :container) :close)
  (call-next-method))

(defmeth name-list-proto2 :remove ()
  (send (send (send self :container) :fake-overlayh) :remove)
  (when (send self :vertical)
        (send (send (send self :container) :fake-overlayv) :remove))
  (send (send self :container) :remove)
  (call-next-method))

(defmeth name-list-proto2 :show-window ()
  (call-next-method)
  (send (send (send self :container) :fake-overlayh) :show-window)
  (when (send self :vertical)
        (send (send (send self :container) :fake-overlayv) :show-window))
  (send (send self :container) :show-window))

(defmeth name-list-proto2 :hide-window ()
  (send (send self :container) :hide-window))

(defmeth name-list-proto2 :always-on-top (&optional (logical nil set))
  (if set (send (send self :container) :slot-value 'top-most-state logical))
  (send (send self :container) :slot-value 'top-most-state))
    

(defmeth name-list-proto2 :plot-help (&optional window-already-exists)
  (unless window-already-exists 
          (plot-help-window "Help for Item List")
          (paste-plot-help (format nil "This window presents a list of items. You can select items in the list to form a subset of ACTIVE items.")))  
  (paste-plot-help (format nil "~2%ACTIVE items are those which are highlighted, or if none are highlighted, those which are listed.~2%"))
  (paste-plot-help (format nil "You make a list item ACTIVE by clicking it. You can activate several items by dragging your cursor over them. You can add items to those which are already active by CTRL-clicking, or CTRL-dragging.~2%"))
  (paste-plot-help (format nil "You build a subset of active items with the buttons in the window. These buttons let you KEEP highlighted items in the subset or DROP them from the subset. You can also UNDO the current highlighting or RESET all items to their original un-highlighted state.~2%"))
  (show-plot-help))


(defmeth graph-proto :in ()
  (send (send self :namelist) :focus-on-selection)
  )

(defmeth graph-proto :out ()
  (send (send self :namelist) :erase-selection)
  )

(defmeth graph-proto :undo ()
  (send (send self :namelist) :unselect-all-points)
  )

(defmeth graph-proto :reset ()
  (send (send self :namelist) :show-all-points)
  )


;;******************
;; varobs-list-proto
;;******************


(defun make-var-list ( &key (show nil) (title "Vars") putin-existing-container
                            (container *desktop-container*))
"Makes a variable namelist with button bar by using containers. PUTIN-EXISTING-CONTAINER is needed by double-name-list"
  (unless putin-existing-container (enable-container container))
  (setf *var-window*
        (send varobs-list-proto :new 0 :show show :title title))
  (unless putin-existing-container (disable-container))
  *var-window*)

(defun make-obs-list ( &key (show nil) (title "Obs") putin-existing-container
                            (container *desktop-container*))
"Makes an observation namelist with button bar by using containers. PUTIN-EXISTING-CONTAINER is needed by double-name-list"
  (unless putin-existing-container (enable-container container))
  (setf *obs-window*
        (send varobs-list-proto :new 0 :show show :title title))
  (setf *mat-window* *obs-window*)
  (unless putin-existing-container (disable-container))
  *obs-window*)

(defproto varobs-list-proto '(container) () name-list-proto2)

(defmeth varobs-list-proto :container (&optional (objid nil set))
  (if set (setf (slot-value 'container) objid))
  (slot-value 'container))

(defmeth varobs-list-proto :redraw ()
  (call-next-method)
  (send self :redraw-overlays))

(defun remove-selected-obs-vars ()
  (send *obs-window* :the-function ':erase-selection)
  (send *var-window* :the-function ':erase-selection)
  )

(defun focus-on-selected-obs-vars ()
  (send *obs-window* :the-function ':focus-on-selection)
  (send *var-window* :the-function ':focus-on-selection)
  )

(defun show-all-obs-vars ()
  (send *obs-window* :the-function ':show-all-points :all t)
  (send *var-window* :the-function ':show-all-points :all t)
  (send *var-window* :set-menus 0)
  )

(defun cancel-obs-vars-selection ()
  (send *obs-window* :the-function ':unselect-all-points)
  (send *var-window* :the-function ':unselect-all-points)
  (when (and (send *var-window* :all-points-showing-p) 
             (send *obs-window* :all-points-showing-p))
        (send *var-window* :set-menus 0))
  )


;;************************************************************************
;; double-name-list-proto 
;;************************************************************************

(defun double-name-list 
  (&optional names1 names2 &key (varobs nil) 
             (show t) (title "Double NameList") 
             (list-titles nil) (style 7)                     
             (size '(250 253)) (location '(100 100)) 
             (putin-this-container *desktop-container*) 
             (in nil)
             )
"Args: &Optional: Names1 Names2 &Key (list-titles nil) (style 7) (putin-this-container nil) (size <(250 250)>) (location <(100 100)>) (show t) (title <\"Double Name List\">) 
Makes a double namelist object with names1 and names2 in the left and right panes of a container window, and a button bar, with Help and namelist buttons. Names1 and Names2 may each be a list of strings, an integer or nil. Each list will be titled when LIST-TITLES is a list of two strings. The double namelist container object will be inside another container when IN specifies the appropriate object.  The window-panes will have borders and title bar as specified by STYLE (7 default). Returns the container objid. Send the message :list1 or list2 to the container for their objid."
  (when in (setf putin-this-container in))
  (send double-name-list-proto2 :new 
        names1 names2 :show show :title title :varobs varobs
        :list-titles list-titles :style-type style
        :putin-this-container putin-this-container 
        :size size :location location))

(defproto double-name-list-proto2 '(fake-overlay inner-container list1 list2 style-type) 
  () container-proto)

(defmeth double-name-list-proto2 :fake-overlay (&optional (objid nil set))
  (if set (setf (slot-value 'fake-overlay) objid))
  (slot-value 'fake-overlay))

(defmeth double-name-list-proto2 :inner-container (&optional (objid nil set))
  (if set (setf (slot-value 'inner-container) objid))
  (slot-value 'inner-container))

(defmeth double-name-list-proto2 :list1 (&optional (objid nil set))
  (if set (setf (slot-value 'list1) objid))
  (slot-value 'list1))

(defmeth double-name-list-proto2 :list2 (&optional (objid nil set))
  (if set (setf (slot-value 'list2) objid))
  (slot-value 'list2))

(defmeth double-name-list-proto2 :style-type (&optional (style-number nil set))
  (if set (setf (slot-value 'style-type) style-number))
  (slot-value 'style-type))

(defmeth double-name-list-proto2 :isnew 
  (names1 names2 
          &key (style-type 7) (show t) (title "Selection") 
          (list-titles (list "List1" "List2"))
          (size '(250 250)) (location '(100 100))
          (putin-this-container nil) 
          (varobs nil))

  (let* ((actcon *active-container*) (container) 
         (fake-overlay) (list1) (list2) )
    (unless list-titles 
            (setf list-titles '("List1" "List2")))
    (enable-container putin-this-container)
    (setf container (call-next-method 0 :putincontainer t :show nil :title title))
    (send container :use-color t)
    (send container :style-type style-type)
;(send container :back-color 'blue)
    (enable-container container)
    (setf fake-overlay (send graph-proto :new 2 :show t :title "Overlay"))
;this shouldn't be needed but it is in fact being overridden somewhere else
;making the buttons not work and generate errors. the function
;is moved to end of this creator function to fix the problem
;    (defmeth fake-overlay :do-click (x y m1 m2);
;	(call-next-method x y m1 m2))
    (send fake-overlay :use-color t)
    (send fake-overlay :back-color 'toolbar-background)
    (defmeth fake-overlay :plot-help ()
      (plot-help-window "Help for Double Item List")
      (paste-plot-help (format nil "This window presents two lists of items. You can select items in these lists to form a subset of ACTIVE items."))
      (send name-list-proto2 :plot-help t))
    (defmeth fake-overlay :in () (focus-on-selected-obs-vars))
    (defmeth fake-overlay :out () (remove-selected-obs-vars))
    (defmeth fake-overlay :undo () (cancel-obs-vars-selection))
    (defmeth fake-overlay :reset () (show-all-obs-vars))
    (setf inner-container (make-container :type style-type :putincontainer t 
                                             :show t :title "Hidden Container"))
    (send inner-container :use-color t)
;(send inner-container :back-color 'green)
    (enable-container inner-container)
    (setf list1 (xlisp-name-list (if names1 names1 1) :show t :title (first list-titles)))
    (enable-container inner-container)
    (setf list2 (xlisp-name-list (if names2 names2 2) :show t :title (second list-titles)))
    (enable-container container)
    (defmeth list1 :fix-name-list ())
    (defmeth list2 :fix-name-list ())
    (send self :inner-container inner-container)
    (send self :list1 list1)
    (send self :list2 list2)
    (send list1 :use-color t);(send list1 :back-color 'red)
    (send list2 :use-color t);(send list2 :back-color 'blue)
    (send self :fake-overlay fake-overlay)
   ; (send fake-overlay :margin 0 24 0 0)
    (send fake-overlay :margin 0 30 0 0)
    (send fake-overlay :select-buttons :vertical nil :double t :hot-spot nil)
    (send list1 :clear)
    (send list1 :new-menu nil)
    (send list1 :menu nil)
    (send list1 :use-color t)
    (send list1 :title (first list-titles))
    (defmeth list1 :do-click (x y m1 m2)
      (send *vista* :check-running-system-processes x y m1 m2 list1)
      (if m2 (send *selector-popup-menu* :popup x y list1))
      (call-next-method x y m1 m2))
    (send list2 :clear)
    (send list2 :new-menu nil)
    (send list2 :menu nil)
    (send list2 :use-color t)
    (send list2 :title (second list-titles))
    (defmeth list2 :do-click (x y m1 m2)
      (send *vista* :check-running-system-processes x y m1 m2 list2)
      (if m2 (send *selector-popup-menu* :popup x y list2))
      (call-next-method x y m1 m2))
    (send fake-overlay :clear)
    (send fake-overlay :new-menu nil)
    (send fake-overlay :menu nil)
    (send fake-overlay :use-color t)
    (send self :location-structure)
    (apply #'send self :size size)
    (apply #'send self :location location)
    (defmeth fake-overlay :plot-help ()
      (send container :plot-help))
    (if (not names1) 
        (send list1 :clear)
        (if (listp names1) 
            (send list1 :add-points (list (iseq (length names1))) 
                  :point-labels names1)
            (send list1 :add-points names1)))
            
    (if (not names2) 
        (send list2 :clear)
        (if (listp names2) 
            (send list2 :add-points (list (iseq (length names2))) 
                  :point-labels names2)
            (send list2 :add-points names2)))
    (send list1 :cursor 'solid-arrow)
    (send list2 :cursor 'solid-arrow)
    (defmeth list1 :do-motion (x y)
	(when *auto-activate* (send *desktop-container* :active-window)))
    (defmeth list2 :do-motion (x y)
      (when *auto-activate* (send *desktop-container* :active-window)))
    (send (send self :fake-overlay) :show-window)
    (send (send self :list1) :show-window)
    (send (send self :list2) :show-window)
    (when show (send self :show-window))
    (if actcon  (enable-container actcon) (disable-container))
    (defmeth fake-overlay :do-click (x y m1 m2)
	(call-next-method x y m1 m2))
    self))

(defmeth double-name-list-proto2 :show-window ()
  (send (send self :fake-overlay) :show-window)
  (send (send self :list1) :show-window)
  (send (send self :list2) :show-window)
  (call-next-method)
  )

(defmeth double-name-list-proto2 :do-key (char shift option) 
  (when *auto-type-shift* 
        (format t "~%[ listener activated ]~%")
        (activate *listener*)
        (top-level nil)
        ; (read *standard-input* (format *standard-output* "~a~%" (string char)))
        ))

(defmeth double-name-list-proto2 :plot-help ()
  (plot-help-window "Help for Double Item List")
  (paste-plot-help (format nil 
"This window presents two lists of items. You can select items in these lists to form a subset of ACTIVE items."))
  (send name-list-proto2 :plot-help t)
  )


(defmeth double-name-list-proto2 :location-structure ()
  (send (send self :fake-overlay) :margin 0 30 0 0)
  (send (send self :fake-overlay) :location 4 13)
  (send (send self :inner-container) :frame-location 0 18)
  (send (send self :list1) :frame-location 0 0)
  (send (send self :list2) :frame-location 
        (+ 2 (ceiling (/ (first (send (send self :inner-container) :size)) 2))) 0)
  )
;(send *selector* :location-structure)


(defmeth double-name-list-proto2 :location-structure ()
  (send (send self :fake-overlay) :location 4 13)
  (send (send self :inner-container) :frame-location 0 18)
  (send (send self :list1) :frame-location 0 0)
  (send (send self :list2) :frame-location 
        (+ 1 (ceiling (/ (first (send (send self :inner-container) :size)) 2))) 0)
  )

(defmeth double-name-list-proto2 :size (&optional w h)
  (when (and w h)
        (let* ((over (send self :fake-overlay))
               (list1 (send self :list1))
               (list2 (send self :list2))
               (inner (send self :inner-container))
               (h-adjust-a  8) 
               (h-adjust-b  8)
               (style-type (send self :style-type))
               )
          (when (or (= style-type  5) (= style-type  7) (= style-type  8)) 
              (setf h-adjust-a -10);10
              (setf h-adjust-b 0))
          (call-next-method w h)
          (when over (send over :size w 3))
          (when inner (send inner :frame-size (+ 10 w) (+ h h-adjust-b)))
          (when list1 (send list1 :frame-size (+ 3 (floor (/ w 2))) (+ h h-adjust-a)))
          (when list2 (send list2 :frame-size (+ 3 (floor (/ w 2))) (+ h h-adjust-a))
                (send list2 :frame-location 
                      (+ 2 (ceiling (/ (first (send inner :size)) 2))) 0))))
  (call-next-method)
  )
;(send *selector* :size)


(defmeth double-name-list-proto2 :size (&optional w h)
  (when (and w h)
        (let* ((over (send self :fake-overlay))
               (list1 (send self :list1))
               (list2 (send self :list2))
               (inner (send self :inner-container))
               (h-adjust-a  10);10
               (h-adjust-b  10)
               (style-type (send self :style-type))
               )
          (when (or (= style-type  5) (= style-type  7) (= style-type  8)) 
              (setf h-adjust-a -10);10
              (setf h-adjust-b 0))
          (call-next-method w h)
          (when over (send over :size (+ 10 w) 1))
          (when inner (send inner :frame-size (+ 10 w) (+ h h-adjust-b)))
          (when list1 (send list1 :frame-size (+ 3 (floor (/ w 2))) (+ h h-adjust-a)))
          (when list2 (send list2 :frame-size (+ 3 (floor (/ w 2))) (+ h h-adjust-a))
                (send list2 :frame-location 
                      (+ 1 (ceiling (/ (first (send inner :size)) 2))) 0))))
  (call-next-method)
  )

(defmeth double-name-list-proto2 :redraw ()
  ;(when (send self :fake-overlay)
  ;      (send (send self :fake-overlay) :redraw))
 ; (send (send self :inner-container) :redraw)
  ;(when (send self :list1)
  ;      (send (send self :list1) :redraw))
  ;(when (send self :list2)
  ;      (send (send self :list2) :redraw))
 ;(when (send self :fake-overlay)
  ;      (send (send self :fake-overlay) :redraw))
  (call-next-method))

(defmeth double-name-list-proto2 :resize ()
  (call-next-method)
  (apply #'send self :size (send self :size)))



(defun varobs-logo (&key free)  
  (let* ((*logo* (make-logo :copyright-at-top t :free free :local-menus t 
                           :type 0 :pop-out nil :message-number 21
                          :container *varobs-obj*))
        (size (send *varobs-obj* :size))
        (marg (floor (/ (- size (list 125 35)) 2))))
    (apply #'send *logo* :size size)
    (send *logo* :frame-location 0 0)
    (send *logo* :margin (first marg) (second marg) (first marg) (second marg)) 
    (send *logo* :scale-type 'nil)
    (send *logo*  :title "")
    (send *logo* :screen-saver t)
    (send *logo* :showing nil)
    (send *logo* :show-window)
    (send *logo* :transf nil)
    (defmeth *logo* :do-click (x y m1 m2)
      (send *varobs-obj* :idle-on t)
      (send *logo* :close))
    (send *logo* :idle-on t)
    (send *logo* :glide 15 1 1 -1 t)
    (send *logo* :showable t)
    (send *logo* :idle-on t)
    (send *logo* :do-idle)
    *logo*))

;;************************
;;modifications to original name-list object
;;used by double-name-list object
;;************************

(defun xlisp-name-list (names &key (show nil) (title "Namelist") 
                        (size '(100 250)) (location '(100 100)))
"Makes a namelist using XLISP code."
  (let ((nl (send name-list-proto :new 
                  (if names (if (listp names) (length names) names) 1) 
                  :show show :title title :size size :location location)))
    (if (not names) (send nl :clear)
        (if (listp names) 
            (send nl :add-points (list (iseq (length names))) 
                   :point-labels names)))
    (apply #'send nl :size size)
    (send name-list-proto :menu-template 
          '(LINK MOUSE DASH ERASE-SELECTION FOCUS-ON-SELECTION 
                 SHOW-ALL COLOR))
    nl))

(defmeth name-list-proto :fix-name-list ())

(defmeth name-list-proto :redraw ()
  (send self :redraw-background)
  (send self :redraw-content)
  (send self :redraw-overlays))

(defmeth name-list-proto :the-function (f &key all)
  (when (> (send self :num-points) 0)
        (cond 
          (all (send self f))
          ((send self :any-points-selected-p) (send self f)))
        (send self :set-data-selection-states)
        ))

(defmeth name-list-proto :set-data-selection-states ()
  (cond 
    ((equal self *obs-window*)
     (if (equal (send *current-data* :datatype) "matrix")
         (send *current-data* :mat-states 
               (send self :point-state (iseq (send *current-data* :nmat))))
         (send *current-data* :obs-states 
               (send self :point-state (iseq (send *current-data* :nobs))))))
    ((equal self *var-window*)
     (send *current-data* :var-states 
           (send self :point-state (iseq (send *current-data* :nvar)))))
    ((equal *current-data* *current-object*)
     (when (send *current-data* :matrices)
           (send *current-data* :mat-states
                 (send self :point-state (iseq (send *current-data* :nmat))))))
    ))

(defmeth name-list-proto :do-select-click (x y m1 m2)
  (call-next-method x y m1 m2)
    (when (> (send self :num-points) 0)
          (send self :set-menus 1)
          (send self :set-data-selection-states)))

(defmeth name-list-proto :set-menus (state)
  (case state
    (0
     (send remove-selection-data-menu-item :enabled nil)
     (send focus-selection-data-menu-item :enabled nil)
     (send unselect-selection-data-menu-item :enabled nil)
     (send cancel-selection-data-menu-item :enabled nil))
    (1
     (send remove-selection-data-menu-item :enabled t)
     (send focus-selection-data-menu-item :enabled t)
     (send unselect-selection-data-menu-item :enabled t)
     (send cancel-selection-data-menu-item :enabled t))
    (2
     )
    ))

(defun set-data-selection-states ()
  (let* ((nobs  (send *current-data* :nobs))
         (nvar  (send *current-data* :nvar))
         (nmats)
         )
    (cond 
      ((send *current-data* :matrices)
       (setf nmats (send *current-data* :nmat))
       (send *current-data* :mat-states
             (send *obs-window* :point-state (iseq nmats))))
      (t
       (send *current-data* :obs-states 
             (send *obs-window* :point-state (iseq nobs)))))
    (send *current-data* :var-states 
          (send *var-window* :point-state (iseq nvar)))))


(defmeth graph-proto :namelist-buttons 
    (&key (margin (list 0 (+ 17 (send self :text-descent)) 0 0)) 
          (help t)
          )
  (when margin (apply #'send self :margin margin))
  (when (= *color-mode* 0) (setf color nil))
  (let ((overlay 
         (first (send self :add-overlay 
                      (send graph-overlay-proto :new :help help))))
        (graph self)
        )
    (defmeth self :do-motion (x y)
      (let* ((margin (send self :margin))
             )
        (cond
          ((and (> (second margin) 0) (<= y (second margin)))
           (send self :cursor 'solid-arrow))
          ((and (> (fourth margin) 0)
                (> y (- (send self :canvas-height) (fourth margin))))
           (send self :cursor 'solid-arrow))
          ((and (> (first margin) 0) (<= x (first margin)))
           (send self :cursor 'solid-arrow))
          ((and (> (third margin) 0) 
                (> x (- (send self :canvas-width) (third margin))))
           (send self :cursor 'solid-arrow))
          (t
           (when (not (eq (send self :cursor) (send self :set-mode-cursor)))
                 (send self :cursor) (send self :set-mode-cursor))
           (send self :do-brush-motion x y)))
        overlay))
    overlay))
